VERSION 5.00
Begin VB.UserControl ContactList 
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   Begin VB.Timer ScrollTimer 
      Interval        =   10
      Left            =   480
      Top             =   3000
   End
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   2535
      Left            =   480
      ScaleHeight     =   2535
      ScaleWidth      =   3375
      TabIndex        =   1
      Top             =   360
      Width           =   3375
   End
   Begin VB.VScrollBar Scroll 
      Height          =   3615
      LargeChange     =   50
      Left            =   4440
      TabIndex        =   0
      Top             =   0
      Visible         =   0   'False
      Width           =   255
   End
End
Attribute VB_Name = "ContactList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Dim objDX7 As New DirectX7
Dim objDD As DirectDraw7

Dim objDI As DirectInput
Dim objMouse As DirectInputDevice
Dim objMouseState As DIMOUSESTATE

Dim objDDPrimSurf As DirectDrawSurface7
Dim objDDSurf As DirectDrawSurface7
Dim ddsd1 As DDSURFACEDESC2
Dim ddsd2 As DDSURFACEDESC2

Dim texCL As DirectDrawSurface7

Dim ddClipper As DirectDrawClipper

Dim Running As Boolean

Dim MouseOverItem As Integer

Private Type ListItem
    FriendlyName As String
    Email As String
    StatusText As String
    Status As String
    DisplayPicture As StdPicture
    Index As Integer
    ParentIndex As Integer
End Type

Private Type ListObject
    Index As Integer
    Name As String
    Collapsed As Boolean
    Item() As ListItem
    ItemCount As Integer
End Type

Private ListObjects() As ListObject
Private ListCount As Integer


Dim SelectedItem As Integer
Public SelectedItemType As String
Public SelectedItemIndex As Integer

'Default Property Values:
Const m_def_ForeColor = 0
Const ContactHeight = 35

'Property Variables:
Dim m_Font As StdFont
Dim m_ForeColor As Long

Dim SkinColour As Integer  ' 1 = Bottom Skin, 0 = Top Skin
Dim s_DisplayName As String

'Event Declarations:
Event Click() 'MappingInfo=Picture1,Picture1,-1,Click
Attribute Click.VB_Description = "Occurs when the user presses and then releases a mouse button over an object."
Event DblClick() 'MappingInfo=Picture1,Picture1,-1,DblClick
Attribute DblClick.VB_Description = "Occurs when the user presses and releases a mouse button and then presses and releases it again over an object."
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Picture1,Picture1,-1,MouseDown
Attribute MouseDown.VB_Description = "Occurs when the user presses the mouse button while an object has the focus."
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Picture1,Picture1,-1,MouseMove
Attribute MouseMove.VB_Description = "Occurs when the user moves the mouse."
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Picture1,Picture1,-1,MouseUp
Attribute MouseUp.VB_Description = "Occurs when the user releases the mouse button while an object has the focus."

Dim ScrollDelta As Long

Private Sub Picture1_Resize()
    AdjustScroll
    BlitIt
End Sub

Private Sub Scroll_Change()
    AdjustScroll
    BlitIt
End Sub

Private Sub Scroll_Scroll()
    BlitIt
End Sub

Public Sub ActivateMouse(FormhWnd As Long)
    Set objDI = objDX7.DirectInputCreate()
            
    Set objMouse = objDI.CreateDevice("GUID_SysMouse")
    
    objMouse.SetCommonDataFormat DIFORMAT_MOUSE
    objMouse.SetCooperativeLevel FormhWnd, DISCL_FOREGROUND Or DISCL_NONEXCLUSIVE
    objMouse.Acquire
End Sub

Private Sub ScrollTimer_Timer()
    'Yey! No subclassing for me. DI for the win (mostly)
    Dim ScrollValue As Long
    ScrollValue = Scroll.Value
    
    ScrollValue = ScrollValue - GetScrollDelta()
    
    If ScrollValue < 0 Then ScrollValue = 0
    If ScrollValue > Scroll.Max Then ScrollValue = Scroll.Max
    
    Scroll.Value = ScrollValue
End Sub

Private Sub UserControl_Initialize()

    Set objDD = objDX7.DirectDrawCreate("")

    With objDD
        .SetCooperativeLevel Picture1.hwnd, DDSCL_NORMAL
        ddsd1.lFlags = DDSD_CAPS
        ddsd1.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
        Set objDDPrimSurf = .CreateSurface(ddsd1)
        
        ddsd2.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
        ddsd2.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        ddsd2.lWidth = Screen.Width / 15
        ddsd2.lHeight = Screen.Height / 15
        Set objDDSurf = .CreateSurface(ddsd2)
        
        Set ddClipper = .CreateClipper(0)
        ddClipper.SetHWnd Picture1.hwnd
        objDDPrimSurf.SetClipper ddClipper
        
        ddsd1.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN
        
        Set texCL = .CreateSurfaceFromFile(App.Path & "/skin/cl.bmp", ddsd1)
        
    End With

    SetFont "Tahoma", 8
End Sub

Private Sub SetFont(FontName As String, FontSize As Integer, Optional FontBold As Boolean, Optional FontItalic As Boolean)
    Dim Font As New StdFont

    Font.Name = FontName
    Font.Size = FontSize
    
    If Not IsMissing(FontBold) Then Font.Bold = FontBold
    If Not IsMissing(FontItalic) Then Font.Italic = FontItalic

    objDDSurf.SetFont Font
End Sub

Private Sub BlitIt()

    Dim ddrval As Long
    Dim r1 As RECT
    Dim r2 As RECT
    
    objDX7.GetWindowRect Picture1.hwnd, r1
    r2.Bottom = Picture1.Height / 15
    r2.Right = Picture1.Width / 15
    
    Call objDDSurf.BltColorFill(r2, &HFFFFFF)
    
    AdjustScroll
    
    DrawBar
    
    DrawContacts
    
    objDDPrimSurf.Blt r1, objDDSurf, r2, DDBLT_WAIT
    
End Sub

Private Sub DrawBar()

    Dim src As RECT
    Dim des As RECT
    
    Dim X, Y As Integer
    
    src.Top = (SkinColour * 39)
    Y = 10 - Scroll.Value
    If Y <= 0 Then src.Top = src.Top - Y
    Y = IIf(Y < 0, 0, Y)
    
    src.Left = 0
    src.Right = 10
    src.Bottom = (SkinColour * 39) + 35
    objDDSurf.BltFast 10, Y, texCL, src, DDBLTFAST_WAIT
    
    
    src.Left = 127
    src.Right = 137
    objDDSurf.BltFast Picture1.Width / 15 - 21, Y, texCL, src, DDBLTFAST_WAIT
    
    src.Left = 12
    src.Right = 124
    
    des.Top = Y
    des.Bottom = 45 - Scroll.Value
    des.Left = 20
    des.Right = Picture1.Width / 15 - 20
    
    objDDSurf.Blt des, texCL, src, DDBLT_WAIT
    
    SetFont "Tahoma", "21", False
    
    If SkinColour = 1 Then
        objDDSurf.SetForeColor RGB(255, 255, 255)
    Else
        objDDSurf.SetForeColor RGB(0, 0, 0)
    End If
    
    DrawText des.Left, des.Bottom - 35, s_DisplayName

End Sub

Private Sub AdjustScroll()

    If 54 + ContactHeight * FullListCount() > Picture1.Height / 15 Then
        Scroll.Visible = True
        Picture1.Move 0, 0, UserControl.ScaleWidth - Scroll.Width, UserControl.ScaleHeight
        Scroll.Left = UserControl.ScaleWidth - Scroll.Width
        Scroll.Height = UserControl.ScaleHeight
        Scroll.Min = 0
        Scroll.Max = (54 + ContactHeight * FullListCount()) - Picture1.Height / 15
    Else
        Scroll.Visible = False
        Picture1.Move 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight
    End If
    
End Sub

Private Function FullListCount() As Integer
    Dim tmpCount As Integer
    Dim i As Integer
    For i = 0 To ListCount - 1
        tmpCount = tmpCount + ListObjects(i).ItemCount
    Next
    tmpCount = tmpCount + ListCount
    FullListCount = tmpCount
End Function

Private Sub DrawContacts()

    Dim i As Integer
    Dim j As Integer
    Dim all As Integer
    For i = 0 To ListCount - 1
        objDDSurf.SetForeColor RGB(0, 0, 0)
        SetFont "Tahoma", 10, True
        DrawText 10, 54 - Scroll.Value + ContactHeight * all, "(" & all & ") " & ListObjects(i).Name
        SetFont "Tahoma", 8, False
        If all = SelectedItem Then


        End If
        all = all + 1
        If ListObjects(i).Collapsed = False Then
            If ListObjects(i).ItemCount > 0 Then
                For j = 0 To ListObjects(i).ItemCount - 1
                    If all = SelectedItem Then

                        objDDSurf.setDrawStyle 5
                        objDDSurf.SetFillColor RGB(15, 202, 249)
                        objDDSurf.DrawBox 0, (54 - Scroll.Value + ContactHeight * all) - (ContactHeight / 4), Picture1.Width / 15, (54 - Scroll.Value + ContactHeight * all) + (ContactHeight / 1.5)
                        objDDSurf.SetForeColor RGB(255, 255, 255)
                    Else
                        objDDSurf.SetForeColor RGB(0, 0, 0)
                    End If
                    DrawText 20, 54 - Scroll.Value + ContactHeight * all, "(" & all & ") " & ListObjects(i).Item(j).FriendlyName
                    all = all + 1
                Next
            End If
        End If
    Next
    
End Sub

Private Sub DrawText(X As Long, Y As Long, stri As String)

    Dim r1 As RECT
    
    objDX7.GetWindowRect Picture1.hwnd, r1
    
    If Len(stri) > 0 Then objDDSurf.DrawText X, Y, stri, False
    
End Sub

Private Sub Picture1_Paint()

    AdjustScroll
    BlitIt
    
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
    
    If X / 15 > 54 Then
        MouseOverItem = (Scroll.Value / ContactHeight) + ((Y / 15) / ContactHeight) - 1
    Else
        MouseOverItem = 666
    End If
    
    AdjustScroll
    BlitIt
    
End Sub

Private Sub UserControl_Paint()

    AdjustScroll
    BlitIt
    
End Sub

Private Sub UserControl_Resize()

    AdjustScroll
    BlitIt
    
End Sub

Private Sub Picture1_Click()
    RaiseEvent Click
End Sub

Private Sub Picture1_DblClick()
    RaiseEvent DblClick
End Sub

Public Property Get Skin() As Integer
    Skin = SkinColour
    BlitIt
End Property

Public Property Let Skin(ByVal New_Skin As Integer)
    SkinColour = New_Skin
    PropertyChanged "Skin"
End Property

Public Property Get Selected() As Integer
    Selected = SelectedItem
    BlitIt
End Property

Public Property Get DisplayName() As String
    DisplayName = s_DisplayName
    BlitIt
End Property

Public Property Let DisplayName(ByVal New_DisplayName As String)
    s_DisplayName = New_DisplayName
    PropertyChanged "DisplayName"
End Property

Public Property Get Font() As StdFont
Attribute Font.VB_Description = "Returns a Font object."
Attribute Font.VB_UserMemId = -512
    Set Font = m_Font
End Property

Public Property Set Font(ByVal New_Font As StdFont)
    Set m_Font = New_Font
    PropertyChanged "Font"
End Property

Public Property Get ForeColor() As Long
Attribute ForeColor.VB_Description = "Returns/sets the foreground color used to display text and graphics in an object."
    ForeColor = m_ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As Long)
    m_ForeColor = New_ForeColor
    PropertyChanged "ForeColor"
End Property

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
    Dim temp As Integer
    temp = (Scroll.Value / ContactHeight) + ((Y / 15) / ContactHeight) - 2
    If Button = vbRightButton Or Button = vbLeftButton Then
        SelectedItem = IIf(temp > 0, temp, 1)
    End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Public Sub Add(FriendlyName As String, Email As String, Status As String, Parent As Integer, Optional StatusText As String, Optional DisplayPicture As StdPicture)
Attribute Add.VB_Description = "Adds a contact to the list"
    Dim tmpItm As ListItem
    
    tmpItm.FriendlyName = FriendlyName
    tmpItm.Email = Email
    tmpItm.Status = Status
    tmpItm.StatusText = StatusText
    
    tmpItm.Index = ListObjects(Parent).ItemCount
    ListObjects(Parent).ItemCount = ListObjects(Parent).ItemCount + 1
    
    ReDim Preserve ListObjects(Parent).Item(ListObjects(Parent).ItemCount)
    ListObjects(Parent).Item(tmpItm.Index) = tmpItm
    
End Sub

Public Sub AddParent(Name As String)
    Dim tmpObj As ListObject
    
    tmpObj.Name = Name
    tmpObj.ItemCount = 0
    tmpObj.Index = ListCount
    ListCount = ListCount + 1
    
    ReDim Preserve ListObjects(ListCount)
    ListObjects(tmpObj.Index) = tmpObj
End Sub

Private Sub UserControl_InitProperties()
    Set m_Font = Ambient.Font
    m_ForeColor = m_def_ForeColor
    SelectedItem = 0
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Set m_Font = PropBag.ReadProperty("Font", Ambient.Font)
    m_ForeColor = PropBag.ReadProperty("ForeColor", m_def_ForeColor)
    SkinColour = PropBag.ReadProperty("SkinColour", "0")
    SelectedItem = PropBag.ReadProperty("Selected", "0")
    s_DisplayName = PropBag.ReadProperty("DisplayName", "Robin - I love you Laura <3")
End Sub

Private Sub UserControl_Terminate()
    On Error Resume Next
    objMouse.Unacquire
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("Font", m_Font, Ambient.Font)
    Call PropBag.WriteProperty("ForeColor", m_ForeColor, m_def_ForeColor)
    Call PropBag.WriteProperty("SkinColour", SkinColour, "0")
    Call PropBag.WriteProperty("DisplayName", s_DisplayName, "Robin - I love you Laura <3")
End Sub

Private Function GetScrollDelta() As Long

    On Error Resume Next

    objMouse.GetDeviceStateMouse objMouseState
    
    GetScrollDelta = objMouseState.z
        
End Function
